home *** CD-ROM | disk | FTP | other *** search
/ A.C.E. 2 / ACE CD 2.iso / FILES / UTILS / AMOSCOMP.DMS / in.adf / Font_Convert.AMOS / Font_Convert.amosSourceCode < prev   
Encoding:
AMOS Source Code  |  1993-02-25  |  3.5 KB  |  141 lines
  1. ' FONT CONVERTER by Francois Lionet
  2. ' AMOS Basic (c) Mandarin / Jawx 1990
  3. '
  4. Curs Off : Flash Off : Fade 2,0,0,0 : Wait 32
  5. TITLE
  6. ALERT["...Seeking disc fonts..."]
  7. Fade 8,0,0,$EEE
  8. Get Fonts 
  9. ' Build up menu
  10. Menu$(1)=" Choose a font "
  11. For N=1 To 50
  12.    If Font$(N)<>""
  13.       If Val(Mid$(Font$(N),31))=8
  14.          Menu$(1,N)=Font$(N)
  15.       End If 
  16.    End If 
  17. Next 
  18. Menu$(2)=" Disk "
  19. Menu$(2,1)=" Save font to current AMOS folder "
  20. Menu$(2,2)=" Save font to another AMOS disc   "
  21. Menu$(2,3)="----------------------------------" : Menu Inactive(2,3)
  22. Menu$(2,4)=" Quit                             "
  23. Set Menu(2,1) To -64,10
  24. Menu On 
  25. ' TEST loop
  26. Do 
  27.    If FLAG=0
  28.       ALERT["Please select a font with menu"]
  29.    Else 
  30.       ALERT["Please select a menu option"]
  31.    End If 
  32.    Repeat : Until Choice
  33.    On Choice(1) Gosub MNFONT,MNDISK
  34.    TITLE
  35. Loop 
  36. ' ---> Font menu 
  37. MNFONT:
  38. Menu Off 
  39. MAKEFONT[Choice(2)]
  40. Set Font 2 : Menu Calc : Menu On 
  41. Return 
  42. ' ---> Disk menu 
  43. MNDISK:
  44. If Choice(2)=1 : SVFONT[":AMOS_System/Default.Font"] : End If 
  45. If Choice(2)=2 : SVFONT[Fsel$("Default.Font","","Please select DEFAULT.FONT file","in AMOS_System folder...")] : End If 
  46. If Choice(2)=4 : Edit : End If 
  47. Return 
  48. Procedure SVFONT[N$]
  49.    Shared FLAG
  50.    If FLAG=0 : ALERT["Font not loaded!"] : Bell : Wait 200 : Pop Proc : End If 
  51.    If N$="" : ALERT["Not done"] : Bell : Wait 100 : Pop Proc : End If 
  52.    ALERT["Saving..."]
  53.    Bsave N$,Start(10) To Start(10)+256*8
  54. End Proc
  55. Procedure TITLE
  56.    Clw 
  57.    Centre At(,10)+Border$("AMOS Basic Font Converter",2)
  58. End Proc
  59. Procedure ALERT[A$]
  60.    Centre At(,22)+Space$(39)
  61.    Centre At(,22)+A$
  62. End Proc
  63. Procedure MAKEFONT[F]
  64.    Shared FLAG
  65.    FLAG=False
  66.    Set Font F
  67.    Clw 
  68.    '
  69.    ' Space for new font 
  70.    Erase 10 : Reserve As Work 10,8*256 : AD=Start(10)+32*8
  71.    '
  72.    ' Reads current font 
  73.    RASTPORT=Areg(0)
  74.    AFONT=Leek(RASTPORT+52)
  75.    CDATA=Leek(AFONT+34)
  76.    CMOD=Deek(AFONT+38)
  77.    CHI=Deek(AFONT+20)
  78.    COFFSET=Leek(AFONT+40)
  79.    CFIRST=Peek(AFONT+32)
  80.    CEND=Peek(AFONT+33)
  81.    PROP=Btst(5,Peek(RASTPORT+23))
  82.    If CHI<>8 or PROP : BADFONT : Pop Proc : End If 
  83.    '
  84.    ' Conversion loop
  85.    ALERT["Processing font"]
  86.    Print At(16,8)+Border$(At(16+8,8+7),1)
  87.    For CC=32 To 255
  88.       If CC>=CFIRST and CC<=CEND
  89.          T=Deek(COFFSET+(CC-CFIRST)*4) : COFF=T/8 : CBIT=T mod 8
  90.          CNBIT=Deek(COFFSET+(CC-CFIRST)*4+2)
  91.          If CNBIT<>8 : BADFONT : Pop Proc : End If 
  92.          Locate 26,8
  93.          For Y=0 To CHI-1
  94.             CAD=CDATA+CMOD*Y+COFF
  95.             N=CBIT
  96.             Locate 16,8+Y
  97.             PP=0
  98.             For L=0 To CNBIT-1
  99.                P=Peek(CAD)
  100.                If Btst(7-N,P)
  101.                   Bset 7-L,PP
  102.                   Print "*";
  103.                Else 
  104.                   Print " ";
  105.                End If 
  106.                Inc N
  107.                If N>8
  108.                   Inc CAD : N=0
  109.                End If 
  110.             Next 
  111.             Poke AD,PP : Inc AD
  112.          Next 
  113.       Else 
  114.          For L=0 To 7
  115.             Poke AD,0 : Inc AD
  116.          Next 
  117.       End If 
  118.    Next 
  119.    '
  120.    ' Add border characters
  121.    For L=0 To 32*8-1
  122.       Poke Start(10)+L,Peek(Start(9)+L)
  123.       Poke Start(10)+128*8+L,Peek(Start(9)+32*8+L)
  124.    Next 
  125.    '
  126.    ' One character set in memory
  127.    Clw 
  128.    FLAG=True
  129. End Proc
  130. Procedure BADFONT
  131.    Bell 
  132.    Clw 
  133.    Centre At(,10)+"I cannot use this font,"
  134.    Centre At(,12)+"I need an 8 pixel FIXED WIDTH font!"
  135.    Centre At(,14)+"You can use the Font Editor from"
  136.    Centre At(,15)+"workbench to convert the font"
  137.    Centre At(,16)+"to fixed width..."
  138.    Centre At(,22)+"... Press mousekey to go on ..."
  139.    Repeat : Until Mouse Click
  140.    Clw 
  141. End Proc